unit memory;

interface

uses classes,sysutils,vm,compiler;

procedure memorywords(vm:TKsanaForthVM);
implementation

//memory
procedure forth_cstore(vm:TKsanaForthVM);
var addr:integer;
begin addr:=vm.pop;
  if not vm.isvalidrange(addr) then begin
    vm.error(format('cstore invalid address %x ',
          [addr]));
    forth_abort(vm);
  end else begin
    pchar(addr)^:=char(vm.pop and $FF);
  end;
end;

procedure forth_store(vm:TKsanaForthVM);
var addr:integer;
begin addr:=vm.pop;
  if not vm.isvalidrange(addr) then begin
    vm.error(format('store invalid address %x ',
          [addr]));
    forth_abort(vm); exit;
  end else begin
    pinteger(addr)^:=vm.pop;
  end;
end;

procedure forth_2store(vm:TKsanaForthVM);
var addr:integer;
begin addr:=vm.pop;
  if not vm.isvalidrange(addr,8) then begin
    vm.error(format('store invalid address %x of double ',
          [addr]));
    forth_abort(vm); exit;
  end else begin
    pint64(addr)^:=vm.dpop;
  end;
end;

procedure forth_on(vm:TKsanaForthVM);
var addr:integer;
begin addr:=vm.pop;
  if not vm.isvalidrange(addr) then begin
    vm.error(format('store invalid address %x ',
          [addr]));
    forth_abort(vm); exit;
  end else begin
    pinteger(addr)^:=1;
  end;
end;

procedure forth_off(vm:TKsanaForthVM);
var addr:integer;
begin addr:=vm.pop;
  if not vm.isvalidrange(addr) then begin
    vm.error(format('store invalid address %x ',
          [addr]));
    forth_abort(vm); exit;
  end else begin
    pinteger(addr)^:=0;
  end;
end;

procedure forth_plusstore(vm:TKsanaForthVM);
var addr:integer;
begin addr:=vm.pop;
if not vm.isvalidrange(addr) then begin
  vm.error(format('store invalid address %x ',
          [addr]));
  forth_abort(vm); exit;
end else begin
  pinteger(addr)^:=pinteger(addr)^+vm.pop;
end;
end;

procedure forth_cfetch(vm:TKsanaForthVM);
var   addr:integer;
begin
  addr:=vm.pop;
  if not vm.isvalidrange(addr) then begin
    vm.error(format('cfetch invalid address %x ',
          [addr]));
    forth_abort(vm);
  end else begin
    vm.push(integer(pchar(addr)^));
  end;
end;

procedure forth_fetch(vm:TKsanaForthVM);
var addr:integer;
begin
  addr:=vm.pop;
  if not vm.isvalidrange(addr) then begin
    vm.error(format('fetch invalid address %x ',
          [addr]));
    forth_abort(vm);
  end else begin
    vm.push(pinteger(addr)^);
  end;
end;

procedure forth_2fetch(vm:TKsanaForthVM);
var addr:integer;
begin
  addr:=vm.pop;
  if not vm.isvalidrange(addr,8) then begin
    vm.error(format('fetch invalid address %x ',
          [addr]));
    forth_abort(vm);
  end else begin
    vm.dpush(pint64(addr)^);
  end;
end;

procedure forth_count(vm:TKsanaForthVM);
begin
  vm.push(integer(pchar(vm.tos)^));
  vm.sec:=vm.sec+1;
end;

procedure forth_zcount(vm:TKsanaForthVM);
begin
  vm.push(length(pchar(vm.tos)));
end;

procedure forth_cell_count(vm:TKsanaForthVM);
begin

  vm.push(pinteger(vm.tos)^);
  vm.sec:=vm.sec+cellsize;
end;

procedure memorywords(vm:TKsanaForthVM);
begin
  vm.addcodeword('c!',integer(@forth_cstore)); //// ( n a -- )
  vm.addcodeword('!',integer(@forth_store)); //// ( i a -- )
  vm.addcodeword('2!',integer(@forth_2store)); //// ( i a -- )
  vm.addcodeword('c@',integer(@forth_cfetch)); //// ( a -- c )
  vm.addcodeword('@',integer(@forth_fetch)); //// ( a -- n )
  vm.addcodeword('2@',integer(@forth_2fetch)); //// ( a -- ilow ihigh )
  vm.addcodeword('count',integer(@forth_count)); //// ( a -- a+1 c )
  vm.addcodeword('cell_count',integer(@forth_cell_count)); //// ( a -- a+4 (a) )
  vm.addcodeword('zcount',integer(@forth_zcount)); //// ( a -- a n )
  vm.addcodeword('on',integer(@forth_on)); //// ( a -- )
  vm.addcodeword('off',integer(@forth_off)); //// ( a -- )
  vm.addcodeword('+!',integer(@forth_plusstore)); //// ( n a -- )
end;

end.
